perm filename M2.F4[M11,LCS] blob
sn#373983 filedate 1978-07-31 generic text, type T, neo UTF8
CGEN1 FUNCTION GENERATOR 1
C *** MUSIC V ***
SUBROUTINE GEN1
CC DIMENSIONI(15000),P(100),IP(20)
COMMON I(1)/P/ P(1)/PARM/IP(1)
EQUIVALENCE (IP6,IP(6))
CX PAUSE 'GEN 1, TOP'
N1=IP(2)+(IFIX(P(4))-1)*IP6
M1=7
SCLFT=IP(15)
102 IF(P(M1+1))103,103,100
100 V1=P(M1-2)*SCLFT
V2=(P(M1)-P(M1-2))/(P(M1+1)-P(M1-1))*SCLFT
MA=N1+IFIX(P(M1-1))
MB=N1+IFIX(P(M1+1))-1
DO 101J=MA,MB
XJ=J-MA
101 I(J)=V1+V2*XJ
IF(IFIX(P(M1+1)).EQ.(IP6-1))GO TO 103
M1=M1+2
GO TO 102
103 I(MB+1)=P(M1)*SCLFT
CX PAUSE 'GEN 1, RETURN'
RETURN
END
CGEN2 FUNCTION GENERATOR 2
C *** MUSIC V ***
SUBROUTINE GEN2
DIMENSION A(1000)
CC DIMENSIONI(15000),P(100),IP(20),A(7000)
CC COMMONI,P/PARM/IP
COMMON I(1)/P/ P(1)/PARM/IP(1)
EQUIVALENCE(I,A),(IP6,IP(6))
CX PAUSE 'GEN 2, TOP'
SCLFT=IP(15)
N1=IP(2)+(IFIX(P(4))-1)*IP6
N2=N1+IP6-1
DO 101K1=N1,N2
101 A(K1)=0.0
FAC=6.283185/(FLOAT(IP6)-1.0)
NMAX=I(1)
N3=5+INT(ABS(P(NMAX)))-1
IF(N3-5)104,100,100
100 DO 103J=5,N3
FACK=FAC*FLOAT(J-4)
DO 102K=N1,N2
102 A(K)=A(K)+SIN(FACK*FLOAT(K-N1))*P(J)
103 CONTINUE
104 N4=N3+1
N5=I(1)-1
IF(N5-N4)114,105,105
105 DO 107J1=N4,N5
FACK=FAC*FLOAT(J1-N4)
DO 106K1=N1,N2
106 A(K1)=A(K1)+COS(FACK*FLOAT(K1-N1))*P(J1)
107 CONTINUE
114 CONTINUE
IF(P(NMAX))112,112,108
108 FMAX=0.0
DO 110K2=N1,N2
IF(ABS(A(K2))-FMAX)110,110,109
109 FMAX=ABS(A(K2))
110 CONTINUE
113 DO 111K3=N1,N2
111 I(K3)=(A(K3)*SCLFT*.99999)/FMAX
CX PAUSE 'GEN 2, RETURN'
RETURN
112 FMAX=.99999
GO TO 113
END
CGEN3 FUNCTION GENERATOR 3
C *** MUSIC V ***
C ASSUMPTIONS--P(4) = THE NUMBER OF THE FUNCTION TO BE GENERATED,
C I(1) = WORD COUNT FOR CURRENT DATA RECORD
C P(5) = THE BEGINNING THE THE LIST OF DESCRIPTION NUMBERS
C IP(2) = THE BEGINNING SUBSCRIPT FOR FUNCTIONS IN THE I ARRAY,
C IP(6) = THE LENGTH OF THE FUNCTIONS
C IP(15) = SCALE FACTOR FOR STORED FUNCTIONS
C
CCC SUBROUTINE GEN3
CCC COMMON I(1)/P/ P(1)/PARM/IP(1)
CCX COMMON I(15000),P(100) /PARM/ IP(20)
CCC EQUIVALENCE (IP6,IP(6))
CCC N=I(1)-5
CCC NL=5
CCC SCLFT=IP(15)
CCC LL=IP6
CCC RMIN=0
CCC RMAX=0
CCC NR=NL+N
CCC DO 10 J=NL,NR
CCC IF(P(J).GT.RMAX) RMAX=P(J)
CCC10 IF(P(J).LT.RMIN) RMIN=P(J)
CCC DIV=AMAX1(ABS(RMIN),ABS(RMAX))
CCC N1 = IP(2) + (IFIX(P(4))-1)*IP6
CCC I(N1)=(P(NL)/DIV)*SCLFT
CCC LAST = N1
CCC DO 100 J=1,N
CCC LL = LL-LL/(N-J+1)
CCC IX = N1+IP6-LL-1
CCC IX2 = NL+J
CCC I(IX)=(P(IX2)/DIV)*SCLFT
CCC DELTA=FLOAT(I(IX))-FLOAT(I(LAST))
CCC NR = IX-LAST-1
CCC SEG = NR+1
CCC HNCR=DELTA/SEG
CCC DO 50 K=1,NR
CCC IX2 = LAST+K
CCC 50 I(IX2)=FLOAT(I(IX2-1))+HNCR
CCC100 LAST=IX
CCC RETURN
CCC END
CDATA3 PASS 3 DATA INPUTING ROUTINE
C *** MUSIC V ***
SUBROUTINE DATA (N)
COMMON I(1)/P/ P(1) /FINOUT/JPEAK,NN,IPEAK
CC COMMON I(15000),P(100)
EQUIVALENCE (K,I),(P2,P(2))
READ (N) K,(P(J),J=1,K)
TYPE 1,P2
CC I(1)=K
IF(JPEAK.LE.IPEAK)RETURN
TYPE 2,JPEAK
IPEAK=JPEAK
C TYPES OUT EACH NEW PEAK AMPL.
RETURN
1 FORMAT('+',F9.2,$)
2 FORMAT('+ AMPL=',I4,$)
END
CPARM CONTROL DATA SPECIFICATION FOR PASS 3
C *** MUSIC V ***
C
C IP(1) = NUMBER OF OP CODES
C IP(2) = BEGINNING SUBSCRIPT OF FIRST FUNCTION
C IP(3) = STANDARD SAMPLING RATE
C IP(4) = BEGINNING SUBSCRIPT OF INSTRUMENT DEFINITIONS
C IP(5) = BEGINNING OF LOCATION TABLE FOR INSTRUMENT DEFINITIONS
C IP(6) = LENGTH OF FUNCTIONS
C IP(7) = BEGINNING OF NOTE CARD PARAMETERS
C IP(8) = LENGTH OF NOTE CARD PARAMETER BLOCKS
C IP(9) = NUMBER OF NOTE CARD PARAMETER BLOCKS
C IP(10)= BEGINNING OF OUTPUT DATA BLOCK
C IP(11)= SOUND ZERO (SILENCE VALUE)
C IP(12)= SCALE FACTOR FOR NOTE CARD PARAMETERS
C IP(13)= BEGINNING OF GENERATOR INPUT-OUTPUT BLOCKS
C IP(14)= LENGTH OF GENERATOR INPUT-OUTPUT BLOCKS
C IP(15)= SCALE FACTOR FOR FUNCTIONS
C
BLOCK DATA
COMMON /PARM/IP(20)
DATA IP/12,512,10000, 7100, 7000,512, 6000,35,27,4487,2048,
1 16 ,4487,512, "77777 ,5*0/
CC DATA IP/12,512,10000,14500,14400,512,13000,35,40,6657,2048,
CC 1 "1000000,6657,512,"377777777777,5*0/
C*****BIG NUMB. IS IBM360'S BIGGEST. 1 65536,6657,512,Z7FFFFFFF/
END
CC****SUBROUTINE DUM
CC****ENTRY SAMGEN
CC****ENTRY GEN4
CC****ENTRY GEN5
CC****END
SUBROUTINE SAMGEN
RETURN
END
CCC SUBROUTINE GEN4
CCC END
CCC SUBROUTINE GEN5
CCC END
C **** DUMMY SUBROUTINES ****
SUBROUTINE FROUT3(IDSK)
C TERMINATE OUTPUT
INTEGER PEAK
COMMON I(1)/P/ P(1)/PARM/IP(1)/FINOUT/PEAK,NRSOR
CC COMMON I(15000),P(100)/PARM/IP(20)/FINOUT/PEAK,NRSOR
K=IP(10)
L=IP(10)+IP(14)-1
DO 1 J=K,L
1 I(J)=0
CALL SAMOUT(IDSK,IP(14))
CC REWIND NWRITE
CC WRITE (6,10) PEAK,NRSOR
TYPE 10,PEAK,NRSOR
CC*** CALL EXIT
IF(IDSK.LT.0)CALL EXIT
J=IP(10)
L=J+1024
DO 2 K=J,L
2 I(K)=0
C WILL WRITE 1024 0'S ON DSK.
C/// CALL FASTOUT(I(J),1024)
C/// CALL FINFILE
CALL EXIT
10 FORMAT ('0PEAK AMPLITUDE WAS',I8/'0NUMBER OF SAMPLES OUT OF RANGE
1WAS',I8)
END
CDSMOUT DEBUG SAMOUT 'C////'=CHANGES FOR PDP11 VERSION
C *** MUSIC V ***
C DEBUG SAMOUT
SUBROUTINE SAMOUT(IDSK,N)
DIMENSION IDBUF(512 )
C//// DIMENSION IDBUF(3071)
CZ DIMENSION IDBUF(2000),MS(3)
C*** IDSK IS FLAG TO WRITE SAMPLES ON DSK -- PDP *****
C*** IDBUF WILL STORE PACKED SAMPLES. ****
CC DIMENSIONI(15000),T(10),P(100),IP(20)
COMMON I(1)/P/ P(1)/PARM/IP(1)/FINOUT/PEAK,NRSOR
CC COMMON I,P/PARM/IP/FINOUT/PEAK,NRSOR
INTEGER PEAK
C//// MNST=768
C//// IF(I(8).NE.0)MNST=1536
CX IF(IDSK.GE.0)GO TO 99
CX N1=N
CX PRINT100,N1
CX 100 FORMAT(7H OUTPUTI6,8H SAMPLES)
CX N2=IP(10)-1
CX N3=10
CX GO TO 104
CX106 DO 101L=1,10
CX J=N2+L
CX101 T(L)=FLOAT(I(J))/FLOAT(IP(12))
CX PRINT102,(T(K),K=1,N3)
CX102 FORMAT(1H 10F11.4)
CX N2=N2+10
CX N1=N1-10
CX IF(N1)103,103,104
CX103 RETURN
CX104 IF(N1-10)105,106,106
CX105 N3=N1
CX GO TO 106
C////99 J=IDSK+1
C//// KOUT=MNST/3
M1=IP(10)
ISC=IP(12)
C** IP(12) IS NOTE PARAM SCALE FACTOR
C//// IDSK=IDSK+N
M2=0
C COUNTS SAMPLES TO DATE
C//// DO 1 K=J,IDSK
MNST=512
DO 1 K=1,512
J=M1+M2
N1=I(J)/ISC
I(J)=0
C***** ZERO THE ARRAY SO LAST TIME WILL WRITE ZEROS AFTER DONE. ****
IF(N1.GT.PEAK)PEAK=N1
IDBUF(K)=N1
1 M2=M2+1
WRITE(23)IDBUF
C//// IF(IDSK.LT.MNST)RETURN
C****MUS5TR****************************************
C//// KL=0
C************ BELOW IS FAIL ROUTINE TO PACK 3 SMPLS INTO 2 WD.
C//// DO 2 K=1,MNST,3
C//// KL=KL+1
C//// 2 CALL PACK(IDBUF(KL),IDBUF(K))
C************ ABOVE IS FAIL ROUTINE TO PACK 3 SMPLS INTO 2 WD.
C************ BELOW IS FORTRAN ROUTINE TO PACK 3 SMPLS INTO 2 WD.
CZ DO 2 K=1,768,3
CZ KL=KL+1
CZ KJ=K-1
CZ MS(1)=IDBUF(K)
CZ IF(MS(1).EQ.2048)MS(1)=2047
C A 2048 IN THE 12 LEFT HAND BITS CREATES PROBLEMS
CZ DO 3 L=2,3
CZ MS(L)=IDBUF(KJ+L)
CZ3 IF(MS(L).LT.0)MS(L)=4096+MS(L)
CZ2 IDBUF(KL)=MS(3)+MS(2)*4096+MS(1)*16777216
C PACKS 3 SMPLS TO A 36-BIT WORD. 4096=2**12, 16---=2**24.
C MS(1) HAS LEFT HAND 12 BITS; MS(2), MIDDLE 12 BITS; MS(3), RIGHT 12.
C NEGATIVE NUMBERS RUN FROM 4095(I.E. -1) TO 2049(I.E. -2048).
C************ ABOVE IS FORTRAN ROUTINE TO PACK 3 SMPLS INTO 2 WD.
C//// CALL FASTOU(IDBUF(1),KOUT)
C//// J=IDSK-MNST
C//// IF(J.LT.1)GO TO 4
C//// DO 5 K=1,J
C////5 IDBUF(K)=IDBUF(MNST+K)
C////4 IDSK=J
C****MUS5TR****************************************
RETURN
END
CERRO1 GENERAL ERROR ROUTINE
C *** MUSIC V ***
SUBROUTINE ERROR(I)
TYPE 100,I
100 FORMAT (' ERROR OF TYPE',I5)
RETURN
END